home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Environments / Yerk 3.6.8 / System source / Event < prev    next >
Encoding:
Text File  |  1995-11-23  |  6.9 KB  |  248 lines  |  [TEXT/YERK]
  1. \ Modification  History
  2. \  4/16/84  NDI Version 1.0
  3. \  4/20/84  NDI Added ClickAction, replaces Middleman
  4. \  5/07/84  NDI now inits FEVENT, uses CALL:
  5. \  8/16/84  CBD MOUSE-EVT handles window directly
  6. \  8/26/84  CBD Deferred  methods for windows
  7. \ 10/12/84  CBD use objPtr for MenuBar
  8. \ 10/25/84  CBD Added click time for double-click use
  9. \ 11/11/84  CBD Added interval timer, wait, Mouse
  10. \  1/14/84  cbd Added modeless dialog support
  11. \ 12/08/85  cdn Fixed put: & click: methods in Mouse
  12. \               Added NULL-EVT-IDLE
  13. \  4/15/86  cdn Removed NULL-EVT-IDLE in favor of actW semaphore
  14. \  8/26/86  cdn Upgraded DISK-EVT to automatically mount volume
  15. \  8/31/88    rfl    added zoomWindow support
  16. \  3/22/90    rfl    multifinder compatible. removed call systemtask for nullevt
  17. \                as well as other things
  18. \  5/29/90    rfl handle bad disk mounts
  19. \  7/25/90    rfl    modified upd-evt and actv-evt for waitnextevent and non-multifinder
  20. \  9/30/90    rfl    next: doesn't need ^base; .pause now in nucleus
  21. \ 10.25.90    rfl    added deactivate and activate messages in multifinder event
  22. \ 12/21/90    rfl    getevent now needs nothing on the stack. This means there can
  23. \                never be more than one event object.
  24. \  1/31/90    rfl    font stuff moved to file
  25. \  6/08/91    rfl    high level events support
  26. \ 10/26/91    rfl    added abort load in (nevent) for either decho state
  27. \  5/07/93    rfl    added modifier key detection
  28. \  5/28/93    rfl    fixed hl-Evt to leave the advertised 0 on stack
  29. \  7/20/95    rfl    changed key-evt to work if there is no app window visible
  30. \ 11/23/95    rfl changed os-evt to check if any window is alive or visible before switch
  31.  
  32. Decimal
  33.  
  34. 'c (nevent1) -> nEvent        \ use as stub until Event is loaded
  35.  
  36. \ forward reference the menu bar
  37. 0 value MenuBar
  38.  
  39. \ max ticks for double click
  40. : dblTicks  $ 2f0 -base @  ;
  41.  
  42. hex
  43. create intSwap
  44.     2017 w,        \ move.l    (sp),d0
  45.     4840 w,        \ swap        d0
  46.     2e80 w,        \ move.l    d0,(sp)
  47. next,
  48. decimal
  49.  
  50. 0 variable theDlg
  51. 0 variable thePoint
  52.  
  53. \ ( gy:gx -- ly:lx )  convert a global point to a local point
  54. : G->L
  55.     thePoint !  thePoint +base
  56.     call GlobalToLocal  thePoint @  ;
  57.  
  58. : l->g thePoint ! thePoint +base call LocalToGlobal thePoint @ ;
  59.  
  60.  
  61. :CLASS Event  <Super X-Array
  62.  
  63.     Int        Evt
  64.     Var        Msg
  65.     Var        Time
  66.     Var        Loc
  67.     Int        Mods
  68.     Int        Mask
  69.     Var        Sleep
  70.     Var        MouseRgn
  71.  
  72.     :M  SLEEP:    put:  Sleep    ;M
  73.     :M  MouseRgn: put:  mouseRgn ;M
  74.     :M  TYPE:     get:  Evt         ;M
  75.     :M  MODS:     get:  Mods     ;M
  76.     :M  SET:      put:  Mask     ;M
  77.     :M  MSG:      get:  Msg      ;M
  78.  
  79.     \ ( -- mpoint )  leaves mouse loc as global toolbox Point
  80.     :M  WHERE:  get:  loc  ;M
  81.  
  82.     \ ( -- #secs )  Leave ticks
  83.     :M  WHEN:   get:  Time  ;M
  84.  
  85.     \ get the next event and exec its handler
  86.     \ ( -- b )  True if we should exit to caller
  87.     :M  NEXT:
  88.         getEvent
  89.         IF get: Evt ELSE 0 THEN
  90.         exec: super
  91.     ;M
  92.  
  93.     \ ( -- )  handle events until a key event occurs
  94.     :M  KEY: BEGIN  next: self UNTIL  ;M
  95.  
  96. ;CLASS
  97.  
  98. ' Event 'c fEvent !
  99.  
  100. \ define the mouse as an object
  101. :CLASS Mouse  <Super Object
  102.  
  103.     Var        Last        \ ticks when last click occurred
  104.     Var        Interval    \ ticks between clicks
  105.  
  106.     \ ( ticks -- )  update the click interval with current sysTicks value
  107.     :M  PUT:  dup get: last - put: interval  put: last  ;M
  108.  
  109.     \ ( -- type )  return the type of click that last occurred: 2=double
  110.     :M  CLICK:  get: interval dup 0> swap dblTicks < and
  111.         IF 2 ELSE 1 THEN  ;M
  112.  
  113.     \ return the mouse position as local point
  114.     :M  WHERE:  ?terminal drop where: fEvent  g->l unPack   ;M
  115.  
  116.     \ return the current state of the mouse - position and button
  117.     \ ( -- x y but )  button non-0 if down
  118.     :M  GET:   where: self  word0 call Button word0  ;M
  119.  
  120. ;CLASS
  121.  
  122. Mouse theMouse
  123.  
  124. \ return true if mouse button is still down
  125. : StillDown?  word0 call StillDown word0  ;
  126.  
  127. \ wait until a mouse click or key event
  128. : waitClick   BEGIN 10 ?event UNTIL ;
  129.  
  130. \ ( -- )  Desktop click handler
  131. : Desk  ;
  132.  
  133. \ ( wind -- )  System  click handler
  134. : Sys    +base abs: fEvent swap call SystemClick  ;
  135.  
  136. 0 value actW    \ Indentifies any active Yerk window which should be idled
  137.  
  138. \ ( -- 0 )  NULL, KEYUP, NETW, DRVR, application events
  139. : NULL-EVT 0 actW -dup IF idle: [ ] THEN    ;    \ If active YERK window, send idle
  140.  
  141. \ ( -- 0 )  mouse down event - perform a window-action
  142. : MOUSE-EVT
  143.     when: fEvent  put: theMouse    \ update click interval
  144.     where: fEvent  find-Window  swap
  145.     Select{    \  Region handlers
  146.         0  Is{  Drop  Desk           }End
  147.         1  Is{  Drop click: MenuBar  }End
  148.         2  Is{  Sys                  }End
  149.         3  Is{  content: [ ]         }End
  150.         4  Is{  drag: [ ]            }End
  151.         5  Is{  grow: [ ]            }End
  152.         6  Is{  Dup +Base  >R Word0 R> where: fEvent
  153.                 call TrackGoAway word0
  154.                 IF  close: [ ]
  155.                 ELSE  Drop THEN    }End
  156.         7  Is{ 7 swap zoom: [ ]  }End
  157.         8  Is{ 8 swap zoom: [ ]  }End
  158.     Default{  abort
  159.     }Select  0
  160. ;
  161.  
  162. \ checks to see if window belongs to the application - necessary for
  163. \ non-multifinder systems while calling waitnextevent
  164. : isAppWindow ( windPtr -- windPtr b) dup 108 + w@ 8 = ;
  165. : handleKey mods: fEvent  $ 100 and    \ command key?
  166.         IF  msg: fEvent  key: menuBar 0    \ check for menu selection
  167.         ELSE  msg: fEvent  mods: fEvent true
  168.         THEN ;
  169.  
  170. \ ( -- keywd modswd t OR f )  get key value
  171. : KEY-EVT 0 call frontwindow -dup
  172.     IF -base isappwindow swap drop
  173.         IF handleKey
  174.         ELSE false
  175.         THEN
  176.     ELSE handleKey
  177.     THEN  ;
  178.  
  179.  
  180. \ ( -- 0 )  handle a disk insert event
  181. : DISK-EVT watchcurs
  182.     msg: fevent intSwap extend 0<
  183.     IF   word0 150 100 pack msg: fevent call dIBadMount i->l drop
  184.     ELSE 154 newPtr msg: fEvent over 22 + w!
  185.          dup fcall PBOffline drop
  186.          dup fcall PBMountVol drop
  187.          killPtr
  188.     THEN arrowcurs 0 ;
  189.  
  190. \ ( -- 0 )  cause window draw
  191. : UPD-EVT   msg: fEvent -base isAppWindow
  192.     IF draw: [ ]  ELSE drop THEN 0  ;
  193.  
  194. \ ( -- 0 )  activate, draw window
  195. : ACTV-EVT
  196.     msg: fEvent -base    isAppWindow \ get the window object
  197.     IF mods: fEvent 01 and
  198.         IF    enable: [ ]
  199.         ELSE  disable: [ ]
  200.         THEN
  201.     ELSE drop
  202.     THEN  0  ;
  203.  
  204. true value inForeGround
  205. nullcfa vect resume
  206. nullcfa vect suspend
  207. nullcfa vect cvtClip
  208. nullcfa vect mouseMoved
  209. 'c drop vect appleEvt
  210. 'c drop vect hlevt
  211.  
  212. 0 value saveWind
  213.  
  214. ( -- 0)
  215. : OS-Evt
  216.     msg: fevent $ 1000000 and
  217.     IF    msg: fevent 1 and
  218.         IF      saveWind -> actw actw IF enable:  actw THEN true -> inForeGround resume
  219.         ELSE  actw -> saveWind actw IF disable: actw THEN false -> inForeGround suspend
  220.         THEN
  221.         msg: fevent 2 and IF cvtClip THEN
  222.     ELSE msg: fevent $ FA000000 and
  223.         IF mouseMoved THEN
  224.     THEN 0 ;
  225.  
  226. ( -- 0) \ High level events
  227. : HL-Evt where: fevent msg: fevent 'type aevt =
  228.     IF AppleEvt ELSE hlEvt THEN 0 ;
  229.  
  230.  
  231. : key     key: fEvent  drop $ ff and ;
  232. 'c key ' abort 16 + !
  233.  
  234. : rekey   'c key  -> keyvec ;
  235.  
  236. \ these check if a particular modifier key is down. They do not check
  237. \  if the particular key is the ONLY modifier key down.
  238. : command? ( -- b) mods: fevent $  100 and 0> ;    \ command key down?
  239. : shift?   ( -- b) mods: fevent $  200 and 0> ;    \ is the shift key held down?
  240. : ctl?        ( -- b) mods: fevent $ 1000 and 0> ;
  241. : option?  ( -- b) mods: fevent $  800 and 0> ;    \ you get the idea
  242.  
  243. \ put it nEvent later - allow background loading and a way to abort
  244. : (nEvent) next: fevent
  245.     IF 2drop \ decho
  246.        .pause key 32 <> IF abort THEN
  247.     THEN ;
  248.